home *** CD-ROM | disk | FTP | other *** search
/ Dr. Windows 3 / dr win3.zip / dr win3 / PROGRAMR / WPJV1N7.ZIP / RTFGEN.ZIP / RTFGEN.PAS < prev    next >
Pascal/Delphi Source File  |  1992-02-23  |  18KB  |  803 lines
  1.                   { RTFGEN }
  2.  
  3. (*********  Source code (C) Copyright 1992, by L. David Baldwin   *********)
  4. (*********                All Rights Reserved                     *********)
  5.  
  6. {$A+,B-,E-,F-,G-,I+,N-,O-,R-,S-,V-,X-}
  7. {$M 16384,0,0}
  8.  
  9. PROGRAM RTFGEN;
  10. Uses Crt{, MySubs};
  11. Const
  12.   TwipsPerSpace = 120;
  13.   DefaultFont : String[6] = '2';
  14.   DefaultFontSize : String[10] = '20';
  15.   ParaChar : Char = '`';
  16.   Tokenleng = 28;         {Max symbol length}
  17.   Tab = #9;
  18.   MaxRes = 13;
  19. Type
  20.   Symb = (
  21.     OtherChar, Comma, Colon, SemiColon, Lbrack, Rbrack, Dot, Slash,
  22.     LLbrack, RRbrack, OtherPunct, Ident, EolSy, Space, ParaSy, TabSy,
  23.     BuildTagSy, TopicSy, TitleSy, KeyWordSy, BrowseSy,
  24.     TopicStart, TopicEnd, DocStartSy, DocEndSy, CommandSy, BMCSy, BMLSy,
  25.     BMRSy, FontCommand, Number, BlockStartSy, BlockEndSy);
  26.   SymString = string[14];
  27. Var
  28.   Sy, SaveSy : Symb;
  29. Const
  30.   ResWord : array[1..MaxRes] of SymString = (
  31.     '\buildtag', '\topic', '\title', '\keyword', '\browse', '\bmc', '\bml',
  32.     '\bmr', '\docstart', '\docend', '\tab', '\blockstart', '\blockend');
  33.   ResSy : array[1..MaxRes] of Symb = (
  34.     BuildTagSy, TopicSy, TitleSy, KeyWordSy, BrowseSy, BMCSy, BMLSy,
  35.     BMRSy, DocStartSy, DocEndSy, TabSy, BlockStartSy, BlockEndSy);
  36. Type
  37.   TokenString = string[Tokenleng];
  38.   String127 = string[127];
  39.   Filestring = string[64];
  40.   PairType = array[0..1] of Char;
  41. Var
  42.   BrackCount, LineNo, Chi, ErrCount : Integer;
  43.   Pair : Word;
  44.   Spair : PairType absolute Pair;
  45.   LCh : Char absolute Pair;
  46.   UCh : Char;
  47.   St : String127;
  48.   ErrFlag, EofInf, InInclude, InTopic : Boolean;
  49.   SourceName : Filestring;
  50.   Inf, Outf : Text;
  51.   InBuff, OutBuff : array[1..1000] of Char;
  52.   Value : LongInt;
  53.   LCToken : TokenString;
  54.   OutString, GlobalHeader, TopicHeader : String;
  55.   BlockHeader : array[1..4] of String;
  56.   BIndex : Integer;
  57.  
  58. {-------------Error}
  59. PROCEDURE Error(II :Integer; S :String127);
  60. Var X,Y : Integer;
  61.   NewS : String127;
  62. begin
  63. GotoXY(1,WhereY);
  64. WriteLn(St);
  65. Y:=WhereY;
  66. X:=II-3; if X<1 then X:=1;
  67. GotoXY(X, Y);
  68. Write('^');
  69. Str(LineNo, NewS);
  70. NewS := NewS + ' Error';
  71. if S[0]>#0 then  NewS:=NewS + ', '+S;
  72. if X+Ord(NewS[0])>80 then X:=X-Ord(NewS[0]) else X:=X+1;
  73. GotoXY(X,Y);  WriteLn(NewS);
  74. ErrCount:=Succ(ErrCount);
  75. if ErrCount>6 then
  76.   begin
  77.   WriteLn('Excessive Number of Errors');
  78.   Halt(1);
  79.   end;
  80. ErrFlag := True;
  81. end;
  82.  
  83. {-------------Positn}
  84. function Positn(Pat, Src : String; I : Integer) : Integer;
  85. {find the position of a substring in a string starting at the Ith char}
  86. var
  87.   N : Integer;
  88. begin
  89. if I < 1 then I := 1;
  90. Delete(Src, 1, I-1);
  91. N := Pos(Pat, Src);
  92. if N = 0 then Positn := 0
  93.   else Positn := N+I-1;
  94. end;
  95.  
  96. {-------------OutFile}
  97. PROCEDURE OutFile(S : String);
  98. var
  99.   WriteIt : boolean;
  100.   Leng, I : Integer;
  101. begin
  102. {a hard to find bug is mismatched braces.  Keep count of these so
  103.  can keep track of matching.}
  104. I := 0;
  105. repeat
  106.   I := Positn('{', S, I+1);
  107.   if (I > 0) then
  108.     if not ((I > 1) and (S[I-1] = '\')) then Inc(BrackCount);
  109. until I = 0;
  110. repeat
  111.   I := Positn('}', S, I+1);
  112.   if (I > 0) then
  113.     if not ((I > 1) and (S[I-1] = '\')) then Dec(BrackCount);
  114. until I = 0;
  115.  
  116. {try to avoid hanging spaces on end of lines as editors delete them}
  117. Leng := Length(OutString)+Length(S);
  118. WriteIt := (Leng >= 75) and (OutString[Length(OutString)] <> ' ')
  119.         or (Leng >= 200);
  120. if WriteIt then
  121.   begin
  122.   WriteLn(Outf, OutString);
  123.   OutString := S;
  124.   end
  125. else OutString := OutString+S;
  126. end;
  127.  
  128. {-------------Flush}
  129. PROCEDURE Flush;
  130. begin
  131. if Length(OutString) > 0 then
  132.   begin WriteLn(OutF, OutString);  OutString := ''; end;
  133. end;
  134.  
  135. {-------------GetCh}
  136. PROCEDURE GetCh;
  137. {Return next char in Uch and Lch with Uch in upper case. Ignore comments}
  138. Var Comment : Boolean;
  139.   PROCEDURE GetchBasic; {read a character and a character pair}
  140.   begin
  141.   if Chi<=Ord(St[0]) then
  142.     begin  {NOTE: pair has the same address as lch}
  143.     Pair := MemW[DSeg : Ofs(St[Chi])];
  144.     if (LCh=Tab) and not InTopic then LCh:=' ';
  145.     UCh := UpCase(LCh);
  146.     Chi := Chi+1;
  147.     end
  148.   else
  149.     if not EOF(Inf) then
  150.       begin
  151.       ReadLn(Inf,St);
  152.       Inc(LineNo);
  153.       St:=St+^M;  {Add EOL}
  154.       Chi:=1;
  155.       GetCh;
  156.       end
  157.     else
  158.       begin
  159.       EofInf:=True;
  160.       if Comment then
  161.         begin
  162.         WriteLn('Open Comment at End of Input File');
  163.         Halt(1);
  164.         end;
  165.       end;
  166.   end;
  167.  
  168. begin  {Getch}
  169. repeat
  170.   if EofInf then
  171.     begin WriteLn('Unexpected End of Input File'); Halt(1) end;
  172.   Comment:=False;
  173.   GetchBasic;
  174.   if (SPair='(*') then
  175.     begin
  176.     Comment:=True;
  177.     repeat GetchBasic; until SPair='*)';
  178.     GetchBasic;  {pass by the '*'}
  179.     end;
  180. until not Comment;
  181. end;
  182.  
  183. {-----------IsPair}
  184. FUNCTION IsPair : Boolean;
  185. Const
  186.   Limit = 8;
  187.   PA : array[1..Limit] of PairType = (
  188.      '[[', ']]', '\[', '\]', '\\', '\`',
  189.      '\{', '\}');        {!! <- if '`' made optional, change!!}
  190. Var
  191.   I : Integer;
  192.   Was : Pairtype;
  193. begin
  194. IsPair := False;
  195. for I := 1 to Limit do
  196.   if PA[I] = Spair then
  197.     begin
  198.     Was := SPair;
  199.     Sy := OtherPunct;
  200.     IsPair := True;
  201.     GetCh;
  202.     case I of
  203.       5,7,8 : LCToken := Was;
  204.       1     : Sy := LLbrack;
  205.       2     : Sy := RRbrack;
  206.       else LCToken := LCh;
  207.       end;
  208.     GetCh;
  209.     Exit;
  210.     end;
  211. end;
  212.  
  213. {-------------GetNumber}
  214. FUNCTION GetNumber : Boolean;  {Pick up a Number}
  215. Var
  216.   Done : Boolean;
  217.   Code : Integer;
  218. begin
  219. case UCh of
  220.     '0'..'9' : LCToken := '';
  221.    else
  222.      begin
  223.      GetNumber := False;
  224.      Exit;
  225.      end;
  226.    end;
  227. GetNumber := True;
  228. Sy  := Number;
  229. Done := False;
  230. if not EofInf then
  231.   while not Done do
  232.     case UCh of
  233.       '0'..'9' :
  234.              begin
  235.              LCToken := LCToken+UCh;
  236.              GetCh;
  237.              end;
  238.       else Done := True;
  239.      end;
  240. Val(LCToken, Value, Code);
  241. end;
  242.  
  243. {-------------GetCommand}
  244. FUNCTION GetCommand : Boolean;  {Pick up a Command}
  245. Label 2;
  246. const
  247.   MaxFC = 10;
  248.   FontCommands : array[1..MaxFC] of string[6] =
  249.     ('f', 'fs', 'b', 'i', 'strike', 'ul', 'ulw', 'uld', 'uldb',
  250.      'plain');
  251. Var
  252.   Done : Boolean;
  253.   I : Integer;
  254.   AlphaOnly : TokenString;
  255. begin
  256. GetCommand := False;
  257. if UCh <> '\' then Exit;
  258.  
  259. GetCommand := True;
  260. Sy := CommandSy;
  261. LCToken := LCh;
  262. AlphaOnly := '';
  263. GetCh;
  264. Done := False;
  265. if not EofInf then
  266.   begin
  267.   while not Done do
  268.     case LCh of
  269.       'a'..'z' :
  270.       begin
  271.       if Length(LCToken)<Tokenleng then
  272.         begin
  273.         Inc(LCToken[0]);
  274.         LCToken[Length(LCToken)] := LCh;
  275.         Inc(AlphaOnly[0]);
  276.         AlphaOnly[Length(AlphaOnly)] := LCh;
  277.         end;
  278.       GetCh;
  279.       end;
  280.       else Done := True;
  281.      end;
  282.   if LCh = '-' then
  283.     begin
  284.     if Length(LCToken)<Tokenleng then
  285.       begin
  286.       Inc(LCToken[0]);
  287.       LCToken[Length(LCToken)] := LCh;
  288.       end;
  289.     GetCh;
  290.     end;
  291.   Done := False;
  292.   while not Done do
  293.     case LCh of
  294.       '0'..'9' :
  295.       begin
  296.       if Length(LCToken)<Tokenleng then
  297.         begin
  298.         Inc(LCToken[0]);
  299.         LCToken[Length(LCToken)] := LCh;
  300.         end;
  301.       GetCh;
  302.       end;
  303.       else Done := True;
  304.      end;
  305.   end;
  306.  
  307. for I := 1 to MaxRes do
  308.   if LCToken = ResWord[I] then
  309.     begin
  310.     Sy := ResSy[I];
  311.     GOTO 2;
  312.     end;
  313. if not InTopic then
  314.   for I := 1 to MaxFC do
  315.     if AlphaOnly = FontCommands[I] then
  316.       begin
  317.       Sy := FontCommand;
  318.       GoTo 2;
  319.       end;
  320. 2 :    {account for possible space after command}
  321. if Length(LCToken)<Tokenleng then
  322.   begin
  323.   Inc(LCToken[0]);
  324.   LCToken[Length(LCToken)] := ' ';
  325.   end;
  326. if UCh = ' ' then GetCh;  {use up a space}
  327. end;
  328.  
  329. {-------------GetIdent}
  330. FUNCTION GetIdent : Boolean;  {Pick up a Symbol}
  331. Var
  332.   Done : Boolean;
  333.   I : Integer;
  334. begin
  335. GetIdent := False;
  336. case UCh of
  337.     'A'..'Z', '_' : ;
  338.    else
  339.      Exit;
  340.    end;
  341. GetIdent := True;
  342. Sy := Ident;
  343. LCToken := LCh;
  344. GetCh;
  345. Done := False;
  346. if not EofInf then
  347.   while not Done do
  348.     case UCh of
  349.       'A'..'Z', '0'..'9', '_' :
  350.           begin
  351.       if Length(LCToken)<Tokenleng then
  352.         begin
  353.         Inc(LCToken[0]);
  354.         LCToken[Length(LCToken)] := LCh;
  355.         end;
  356.       Ge